perm filename TYPES.LSP[SCH,LSP] blob
sn#688855 filedate 1982-11-14 generic text, type T, neo UTF8
;;; -*-LISP-*-
(HERALD TYPES "")
(eval-when (compile) (load "scm:umacro"))
(eval-when (compile) (load "scm:smacro"))
;;; Identifying object types
(DEFUN-IMPORT primitive-type (object)
(cond ((numberp object) 'NUMBER)
((null object) 'NULL)
((symbolp object) 'SYMBOL)
((pairp object) 'PAIR)
((hunkp object)
(caseq (object-type object)
(*array* 'ARRAY)
(*control-point* 'CONTROL-POINT)
(*procedure*
(let ((name-field (procedure-name object)))
(cond ((atom? name-field)
'COMPOUND-PROCEDURE)
((eq (car name-field)
'&advised-primitive-procedure)
'PRIMITIVE-PROCEDURE)
(t 'COMPOUND-PROCEDURE))))
((SUBR LSUBR UNFORCED-SUBR
UNFORCED-LSUBR
BUT-1-FORCED-SUBR EXPR)
'PRIMITIVE-PROCEDURE)
(*ENVIRONMENT* 'ENVIRONMENT)
(*delayed* 'DELAYED-OBJECT)
(T 'Unidentified-Object)))
(T 'Unidentified-Object)))
(DEFUN-IMPORT list? (object)
(or (null object) (pairp object)))
;;; ATOM? defined in UPROCS
(DEFUN-IMPORT (applicable? sch-applicable?) (object)
(or (eq (primitive-type object) 'COMPOUND-PROCEDURE)
(eq (primitive-type object) 'PRIMITIVE-PROCEDURE)))
(DEFUN-IMPORT (environment? sch-environment?) (object)
(environment? object))
(ADD-TO-LISP-IMPORTS
'((EQ? EQ)
(SYMBOL? SYMBOLP) (NUMBER? NUMBERP)
(PAIR? PAIRP) (EXTEND? HUNKP) (HUNK? HUNKP)
(NULL? NULL) (NIL? NULL)))
(ADD-TO-LISP-IMPORTS
'(RPLACX CXR HUNK HUNKSIZE))
(ADD-TO-LISP-IMPORTS
'((alphaless? alphalessp) gensym intern maknam readlist
filep mergef namestring deletef))
;;; Environment Hacking
(DEFUN-IMPORT (frame-formals sch-frame-formals) (env)
(frame-formals env))
(DEFUN-IMPORT (frame-arguments sch-frame-arguments) (env)
(frame-arguments env))
(DEFUN-IMPORT (aux-variables sch-aux-variables) (env)
(aux-variables env))
(DEFUN-IMPORT (aux-values sch-aux-values) (env)
(aux-values env))
(DEFUN-IMPORT (frame-procedure sch-frame-procedure) (env)
(frame-procedure env))
(DEFUN-IMPORT (frame-parent sch-previous-frame) (env)
(previous-frame env))
(DEFUN-IMPORT frame-bindings (env)
(nconc
(mapcar '(lambda (formal arg) (list formal arg))
(frame-formals env)
(frame-arguments env))
(mapcar '(lambda (var val) (list var val))
(aux-variables env)
(aux-values env))))
;;; environment probes.
(DEFUN-IMPORT locally-defined? (frame var)
(or (memq var (aux-variables frame))
(memq var (frame-formals frame))))
(DEFUN-IMPORT defined? (env var)
(do ((fr env (previous-frame fr)))
((null fr)
(globally-bound? var))
(cond ((locally-defined? fr var)
(return t)))))
;;; Procedure Hacking
(DEFUN-IMPORT (SET-PROCEDURE-CLASS SCH-SET-PROCEDURE-CLASS) (PROC VAL)
(SET-PROCEDURE-CLASS PROC VAL))
(DEFUN-IMPORT (SET-PROCEDURE-OBJECT SCH-SET-PROCEDURE-OBJECT) (PROC OBJECT)
(SET-PROCEDURE-OBJECT PROC OBJECT))
(DEFUN-IMPORT (SET-PROCEDURE-NAME SCH-SET-PROCEDURE-NAME) (PROC NAME)
(SET-PROCEDURE-NAME PROC NAME))
(DEFUN-IMPORT (SET-PROCEDURE-ENVIRONMENT SCH-SET-PROCEDURE-ENVIRONMENT) (PROC ENV)
(SET-PROCEDURE-ENVIRONMENT PROC ENV))
(eval-when (compile) (load "scm:amacro"))
(DEFUN-IMPORT (procedure-name sch-procedure-name) (proc)
(let ((name-field (procedure-name proc)))
(if (atom? name-field) ; unadvised
name-field
(advised-name name-field))))
(defmacro direct-formals (proc)
`(let ((formals-field
(cond ((eq (object-type ,proc) '*procedure*)
(formal-parameters ,proc))
(t
nil))))
(cond ((eq (car formals-field) '&rest)
(cadr formals-field))
(t
formals-field))))
(defun direct-procedure-formals (proc) (direct-formals proc))
(DEFUN-IMPORT (procedure-formals sch-procedure-formals) (proc)
(let ((name-field (procedure-name proc)))
(cond ((atom? name-field)
(direct-formals proc))
(t (sch-procedure-formals (advised-proc name-field))))))
(defmacro direct-procedure-body (proc)
`(cond ((eq (object-type ,proc) '*procedure*)
(cddr (unsyntax-procedure-definition ,proc)))
(t
nil)))
(DEFUN-IMPORT (procedure-body sch-procedure-body) (proc)
(let ((name-field (procedure-name proc)))
(cond ((atom? name-field) ; unadvised
(direct-procedure-body proc))
(t
(sch-procedure-body (advised-proc name-field))))))
(defmacro direct-procedure-environment (proc)
`(cond ((eq (object-type ,proc) '*procedure*)
(procedure-environment ,proc))
(t
nil)))
(DEFUN-IMPORT (procedure-environment sch-procedure-environment) (proc)
(let ((name-field (procedure-name proc)))
(cond ((atom? name-field) ; unadvised
(direct-procedure-environment proc))
(t
(sch-procedure-environment proc)))))